home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Net / Server.pm < prev    next >
Encoding:
Perl POD Document  |  2007-07-25  |  39.8 KB  |  1,486 lines
  1. # -*- perl -*-
  2. #
  3. #  Net::Server - Extensible Perl internet server
  4. #
  5. #  $Id: Server.pm,v 1.114 2007/07/25 16:21:14 rhandom Exp $
  6. #
  7. #  Copyright (C) 2001-2007
  8. #
  9. #    Paul Seamons
  10. #    paul@seamons.com
  11. #    http://seamons.com/
  12. #
  13. #    Rob Brown bbb@cpan,org
  14. #
  15. #  This package may be distributed under the terms of either the
  16. #  GNU General Public License
  17. #    or the
  18. #  Perl Artistic License
  19. #
  20. #  All rights reserved.
  21. #
  22. ################################################################
  23.  
  24. package Net::Server;
  25.  
  26. use strict;
  27. use vars qw($VERSION);
  28. use Socket qw(inet_aton inet_ntoa AF_INET AF_UNIX SOCK_DGRAM SOCK_STREAM);
  29. use IO::Socket ();
  30. use IO::Select ();
  31. use POSIX ();
  32. use Fcntl ();
  33. use FileHandle;
  34. use Net::Server::Proto ();
  35. use Net::Server::Daemonize qw(check_pid_file create_pid_file
  36.                               get_uid get_gid set_uid set_gid
  37.                               safe_fork
  38.                               );
  39.  
  40. $VERSION = '0.97';
  41.  
  42. ###----------------------------------------------------------------###
  43.  
  44. sub new {
  45.   my $class = shift || die "Missing class";
  46.   my $args  = @_ == 1 ? shift : {@_};
  47.   my $self  = bless {server => { %$args }}, $class;
  48.   return $self;
  49. }
  50.  
  51. sub _initialize {
  52.   my $self = shift;
  53.  
  54.   ### need a place to store properties
  55.   $self->{server} = {} unless defined($self->{server}) && ref($self->{server});
  56.  
  57.   ### save for a HUP
  58.   $self->commandline($self->_get_commandline)
  59.       if ! eval { $self->commandline };
  60.  
  61.   ### prepare to cache configuration parameters
  62.   $self->{server}->{conf_file_args} = undef;
  63.   $self->{server}->{configure_args} = undef;
  64.  
  65.   $self->configure_hook;      # user customizable hook
  66.  
  67.   $self->configure(@_);       # allow for reading of commandline,
  68.                               # program, and configuration file parameters
  69.  
  70.   ### allow yet another way to pass defaults
  71.   my $defaults = $self->default_values || {};
  72.   foreach my $key (keys %$defaults) {
  73.     next if ! exists $self->{server}->{$key};
  74.     if (ref $self->{server}->{$key} eq 'ARRAY') {
  75.       if (! @{ $self->{server}->{$key} }) { # was empty
  76.         my $val = $defaults->{$key};
  77.         $self->{server}->{$key} = ref($val) ? $val : [$val];
  78.       }
  79.     } elsif (! defined $self->{server}->{$key}) {
  80.       $self->{server}->{$key} = $defaults->{$key};
  81.     }
  82.   }
  83.  
  84.   ### get rid of cached config parameters
  85.   delete $self->{server}->{conf_file_args};
  86.   delete $self->{server}->{configure_args};
  87.  
  88. }
  89.  
  90. ###----------------------------------------------------------------###
  91.  
  92. ### program flow
  93. sub run {
  94.  
  95.   ### pass package or object
  96.   my $self = ref($_[0]) ? shift() : shift->new;
  97.  
  98.   $self->_initialize(@_ == 1 ? %{$_[0]} : @_);     # configure all parameters
  99.  
  100.   $self->post_configure;      # verification of passed parameters
  101.  
  102.   $self->post_configure_hook; # user customizable hook
  103.  
  104.   $self->pre_bind;            # finalize ports to be bound
  105.  
  106.   $self->bind;                # connect to port(s)
  107.                               # setup selection handle for multi port
  108.  
  109.   $self->post_bind_hook;      # user customizable hook
  110.  
  111.   $self->post_bind;           # allow for chrooting,
  112.                               # becoming a different user and group
  113.  
  114.   $self->pre_loop_hook;       # user customizable hook
  115.  
  116.   $self->loop;                # repeat accept/process cycle
  117.  
  118.   ### routines inside a standard $self->loop
  119.   # $self->accept             # wait for client connection
  120.   # $self->run_client_connection # process client
  121.   # $self->done               # indicate if connection is done
  122.  
  123.   $self->server_close;        # close the server and release the port
  124.                               # this will run pre_server_close_hook
  125.                               #               close_children
  126.                               #               post_child_cleanup_hook
  127.                               #               shutdown_sockets
  128.                               # and either exit or run restart_close_hook
  129. }
  130.  
  131. ### standard connection flow
  132. sub run_client_connection {
  133.   my $self = shift;
  134.  
  135.   $self->post_accept;         # prepare client for processing
  136.  
  137.   $self->get_client_info;     # determines information about peer and local
  138.  
  139.   $self->post_accept_hook;    # user customizable hook
  140.  
  141.   if( $self->allow_deny             # do allow/deny check on client info
  142.       && $self->allow_deny_hook ){  # user customizable hook
  143.  
  144.     $self->process_request;   # This is where the core functionality
  145.                               # of a Net::Server should be.  This is the
  146.                               # only method necessary to override.
  147.   }else{
  148.  
  149.     $self->request_denied_hook;     # user customizable hook
  150.  
  151.   }
  152.  
  153.   $self->post_process_request_hook; # user customizable hook
  154.  
  155.   $self->post_process_request;      # clean up client connection, etc
  156.  
  157.   $self->post_client_connection_hook; # one last hook
  158. }
  159.  
  160. ###----------------------------------------------------------------###
  161.  
  162. sub _get_commandline {
  163.   my $self = shift;
  164.   my $prop = $self->{server};
  165.  
  166.   ### see if we can find the full command line
  167.   if (open _CMDLINE, "/proc/$$/cmdline") { # unix specific
  168.     my $line = do { local $/ = undef; <_CMDLINE> };
  169.     close _CMDLINE;
  170.     if ($line =~ /^(.+)$/) { # need to untaint to allow for later hup
  171.       return [split /\0/, $1];
  172.     }
  173.   }
  174.  
  175.   my $script = $0;
  176.   $script = $ENV{'PWD'} .'/'. $script if $script =~ m|^[^/]+/| && $ENV{'PWD'}; # add absolute to relative
  177.   $script =~ /^(.+)$/; # untaint for later use in hup
  178.   return [ $1, @ARGV ]
  179. }
  180.  
  181. sub commandline {
  182.     my $self = shift;
  183.     if (@_) { # allow for set
  184.       $self->{server}->{commandline} = ref($_[0]) ? shift : \@_;
  185.     }
  186.     return $self->{server}->{commandline} || die "commandline was not set during initialization";
  187. }
  188.  
  189. ###----------------------------------------------------------------###
  190.  
  191. ### any values to set if no configuration could be found
  192. sub default_values { {} }
  193.  
  194. ### any pre-initialization stuff
  195. sub configure_hook {}
  196.  
  197.  
  198. ### set up the object a little bit better
  199. sub configure {
  200.   my $self = shift;
  201.   my $prop = $self->{server};
  202.   my $template = undef;
  203.   local @_ = @_; # fix some issues under old perls on alpha systems
  204.  
  205.   ### allow for a template to be passed
  206.   if( $_[0] && ref($_[0]) ){
  207.     $template = shift;
  208.   }
  209.  
  210.   ### do command line
  211.   $self->process_args( \@ARGV, $template ) if defined @ARGV;
  212.  
  213.   ### do startup file args
  214.   ### cache a reference for multiple calls later
  215.   my $args = undef;
  216.   if( $prop->{configure_args} && ref($prop->{configure_args}) ){
  217.     $args = $prop->{configure_args};
  218.   }else{
  219.     $args = $prop->{configure_args} = \@_;
  220.   }
  221.   $self->process_args( $args, $template ) if defined $args;
  222.  
  223.   ### do a config file
  224.   if( defined $prop->{conf_file} ){
  225.     $self->process_conf( $prop->{conf_file}, $template );
  226.   } else {
  227.     ### look for a default conf_file
  228.     my $def = $self->default_values || {};
  229.     if ($def->{conf_file}) {
  230.         $self->process_conf( $def->{conf_file}, $template );
  231.     }
  232.   }
  233.  
  234. }
  235.  
  236.  
  237. ### make sure it has been configured properly
  238. sub post_configure {
  239.   my $self = shift;
  240.   my $prop = $self->{server};
  241.  
  242.   ### set the log level
  243.   if( !defined $prop->{log_level} || $prop->{log_level} !~ /^\d+$/ ){
  244.     $prop->{log_level} = 2;
  245.   }
  246.   $prop->{log_level} = 4 if $prop->{log_level} > 4;
  247.  
  248.  
  249.   ### log to STDERR
  250.   if( ! defined($prop->{log_file}) ){
  251.     $prop->{log_file} = '';
  252.  
  253.   ### log to syslog
  254.   }elsif( $prop->{log_file} eq 'Sys::Syslog' ){
  255.  
  256.     $self->open_syslog;
  257.  
  258.   ### open a logging file
  259.   }elsif( $prop->{log_file} && $prop->{log_file} ne 'Sys::Syslog' ){
  260.  
  261.     die "Unsecure filename \"$prop->{log_file}\""
  262.       unless $prop->{log_file} =~ m|^([\w\.\-/\\]+)$|;
  263.     $prop->{log_file} = $1;
  264.     open(_SERVER_LOG, ">>$prop->{log_file}")
  265.       or die "Couldn't open log file \"$prop->{log_file}\" [$!].";
  266.     _SERVER_LOG->autoflush(1);
  267.     $prop->{chown_log_file} = 1;
  268.  
  269.   }
  270.  
  271.   ### see if a daemon is already running
  272.   if( defined $prop->{pid_file} ){
  273.     if( ! eval{ check_pid_file( $prop->{pid_file} ) } ){
  274.       if (! $ENV{BOUND_SOCKETS}) {
  275.         warn $@;
  276.       }
  277.       $self->fatal( $@ );
  278.     }
  279.   }
  280.  
  281.   ### completetly daemonize by closing STDIN, STDOUT (should be done before fork)
  282.   if( ! $prop->{_is_inet} ){
  283.     if( $prop->{setsid} || length($prop->{log_file}) ){
  284.       open(STDIN,  '</dev/null') || die "Can't read /dev/null  [$!]";
  285.       open(STDOUT, '>/dev/null') || die "Can't write /dev/null [$!]";
  286.     }
  287.   }
  288.  
  289.   if (! $ENV{BOUND_SOCKETS}) {
  290.     ### background the process - unless we are hup'ing
  291.     if( $prop->{setsid} || defined($prop->{background}) ){
  292.       my $pid = eval{ safe_fork() };
  293.       if( not defined $pid ){ $self->fatal( $@ ); }
  294.       exit(0) if $pid;
  295.       $self->log(2,"Process Backgrounded");
  296.     }
  297.  
  298.     ### completely remove myself from parent process - unless we are hup'ing
  299.     if( $prop->{setsid} ){
  300.       &POSIX::setsid();
  301.     }
  302.   }
  303.  
  304.   ### completetly daemonize by closing STDERR (should be done after fork)
  305.   if( length($prop->{log_file}) && $prop->{log_file} ne 'Sys::Syslog' ){
  306.     open STDERR, '>&_SERVER_LOG' || die "Can't open STDERR to _SERVER_LOG [$!]";
  307.   }elsif( $prop->{setsid} ){
  308.     open STDERR, '>&STDOUT' || die "Can't open STDERR to STDOUT [$!]";
  309.   }
  310.  
  311.   ### allow for a pid file (must be done after backgrounding and chrooting)
  312.   ### Remove of this pid may fail after a chroot to another location...
  313.   ### however it doesn't interfere either.
  314.   if( defined $prop->{pid_file} ){
  315.     if( eval{ create_pid_file( $prop->{pid_file} ) } ){
  316.       $prop->{pid_file_unlink} = 1;
  317.     }else{
  318.       $self->fatal( $@ );
  319.     }
  320.   }
  321.  
  322.   ### make sure that allow and deny look like array refs
  323.   $prop->{allow} = [] unless defined($prop->{allow}) && ref($prop->{allow});
  324.   $prop->{deny}  = [] unless defined($prop->{deny})  && ref($prop->{deny} );
  325.   $prop->{cidr_allow} = [] unless defined($prop->{cidr_allow}) && ref($prop->{cidr_allow});
  326.   $prop->{cidr_deny}  = [] unless defined($prop->{cidr_deny})  && ref($prop->{cidr_deny} );
  327.  
  328. }
  329.  
  330.  
  331. ### user customizable hook
  332. sub post_configure_hook {}
  333.  
  334.  
  335. ### make sure we have good port parameters
  336. sub pre_bind {
  337.   my $self = shift;
  338.   my $prop = $self->{server};
  339.  
  340.   my $ref   = ref($self);
  341.   no strict 'refs';
  342.   my $super = ${"${ref}::ISA"}[0];
  343.   use strict 'refs';
  344.   my $ns_type = (! $super || $ref eq $super) ? '' : " (type $super)";
  345.   $self->log(2,$self->log_time ." ". ref($self) .$ns_type. " starting! pid($$)");
  346.  
  347.   ### set a default port, host, and proto
  348.   $prop->{port} = [$prop->{port}] if defined($prop->{port}) && ! ref($prop->{port});
  349.   if (! defined($prop->{port}) || ! @{ $prop->{port} }) {
  350.     $self->log(2,"Port Not Defined.  Defaulting to '20203'\n");
  351.     $prop->{port}  = [ 20203 ];
  352.   }
  353.  
  354.   $prop->{host} = []              if ! defined $prop->{host};
  355.   $prop->{host} = [$prop->{host}] if ! ref     $prop->{host};
  356.   push @{ $prop->{host} }, (($prop->{host}->[-1]) x (@{ $prop->{port} } - @{ $prop->{host}})); # augment hosts with as many as port
  357.   foreach my $host (@{ $prop->{host} }) {
  358.     $host = '*' if ! defined $host || ! length $host;;
  359.     $host = ($host =~ /^([\w\.\-\*\/]+)$/) ? $1 : $self->fatal("Unsecure host \"$host\"");
  360.   }
  361.  
  362.   $prop->{proto} = []               if ! defined $prop->{proto};
  363.   $prop->{proto} = [$prop->{proto}] if ! ref     $prop->{proto};
  364.   push @{ $prop->{proto} }, (($prop->{proto}->[-1]) x (@{ $prop->{port} } - @{ $prop->{proto}})); # augment hosts with as many as port
  365.   foreach my $proto (@{ $prop->{proto} }) {
  366.       $proto ||= 'tcp';
  367.       $proto = ($proto =~ /^(\w+)$/) ? $1 : $self->fatal("Unsecure proto \"$proto\"");
  368.   }
  369.  
  370.   ### loop through the passed ports
  371.   ### set up parallel arrays of hosts, ports, and protos
  372.   ### port can be any of many types (tcp,udp,unix, etc)
  373.   ### see perldoc Net::Server::Proto for more information
  374.   my %bound;
  375.   foreach (my $i = 0 ; $i < @{ $prop->{port} } ; $i++) {
  376.     my $port  = $prop->{port}->[$i];
  377.     my $host  = $prop->{host}->[$i];
  378.     my $proto = $prop->{proto}->[$i];
  379.     if ($bound{"$host/$port/$proto"}++) {
  380.       $self->log(2, "Duplicate configuration (".(uc $proto)." port $port on host $host - skipping");
  381.       next;
  382.     }
  383.     my $obj = $self->proto_object($host, $port, $proto) || next;
  384.     push @{ $prop->{sock} }, $obj;
  385.   }
  386.   if (! @{ $prop->{sock} }) {
  387.     $self->fatal("No valid socket parameters found");
  388.   }
  389.  
  390.   $prop->{listen} = Socket::SOMAXCONN()
  391.     unless defined($prop->{listen}) && $prop->{listen} =~ /^\d{1,3}$/;
  392.  
  393. }
  394.  
  395. ### method for invoking procol specific bindings
  396. sub proto_object {
  397.   my $self = shift;
  398.   my ($host,$port,$proto) = @_;
  399.   return Net::Server::Proto->object($host,$port,$proto,$self);
  400. }
  401.  
  402. ### bind to the port (This should serve all but INET)
  403. sub bind {
  404.   my $self = shift;
  405.   my $prop = $self->{server};
  406.  
  407.   ### connect to previously bound ports
  408.   if( exists $ENV{BOUND_SOCKETS} ){
  409.  
  410.     $self->restart_open_hook();
  411.  
  412.     $self->log(2, "Binding open file descriptors");
  413.  
  414.     ### loop through the past information and match things up
  415.     foreach my $info (split /\n/, $ENV{BOUND_SOCKETS}) {
  416.       my ($fd, $hup_string) = split /\|/, $info, 2;
  417.       $fd = ($fd =~ /^(\d+)$/) ? $1 : $self->fatal("Bad file descriptor");
  418.       foreach my $sock ( @{ $prop->{sock} } ){
  419.         if ($hup_string eq $sock->hup_string) {
  420.           $sock->log_connect($self);
  421.           $sock->reconnect($fd, $self);
  422.           last;
  423.         }
  424.       }
  425.     }
  426.     delete $ENV{BOUND_SOCKETS};
  427.  
  428.   ### connect to fresh ports
  429.   }else{
  430.  
  431.     foreach my $sock ( @{ $prop->{sock} } ){
  432.       $sock->log_connect($self);
  433.       $sock->connect( $self );
  434.     }
  435.  
  436.   }
  437.  
  438.   ### if more than one port we'll need to select on it
  439.   if( @{ $prop->{port} } > 1 || $prop->{multi_port} ){
  440.     $prop->{multi_port} = 1;
  441.     $prop->{select} = IO::Select->new();
  442.     foreach ( @{ $prop->{sock} } ){
  443.       $prop->{select}->add( $_ );
  444.     }
  445.   }else{
  446.     $prop->{multi_port} = undef;
  447.     $prop->{select}     = undef;
  448.   }
  449.  
  450. }
  451.  
  452.  
  453. ### user customizable hook
  454. sub post_bind_hook {}
  455.  
  456.  
  457. ### secure the process and background it
  458. sub post_bind {
  459.   my $self = shift;
  460.   my $prop = $self->{server};
  461.  
  462.  
  463.   ### figure out the group(s) to run as
  464.   if( ! defined $prop->{group} ){
  465.     $self->log(1,"Group Not Defined.  Defaulting to EGID '$)'\n");
  466.     $prop->{group}  = $);
  467.   }else{
  468.     if( $prop->{group} =~ /^([\w-]+( [\w-]+)*)$/ ){
  469.       $prop->{group} = eval{ get_gid( $1 ) };
  470.       $self->fatal( $@ ) if $@;
  471.     }else{
  472.       $self->fatal("Invalid group \"$prop->{group}\"");
  473.     }
  474.   }
  475.  
  476.  
  477.   ### figure out the user to run as
  478.   if( ! defined $prop->{user} ){
  479.     $self->log(1,"User Not Defined.  Defaulting to EUID '$>'\n");
  480.     $prop->{user}  = $>;
  481.   }else{
  482.     if( $prop->{user} =~ /^([\w-]+)$/ ){
  483.       $prop->{user} = eval{ get_uid( $1 ) };
  484.       $self->fatal( $@ ) if $@;
  485.     }else{
  486.       $self->fatal("Invalid user \"$prop->{user}\"");
  487.     }
  488.   }
  489.  
  490.  
  491.   ### chown any files or sockets that we need to
  492.   if( $prop->{group} ne $) || $prop->{user} ne $> ){
  493.     my @chown_files = ();
  494.     foreach my $sock ( @{ $prop->{sock} } ){
  495.       push @chown_files, $sock->NS_unix_path
  496.         if $sock->NS_proto eq 'UNIX';
  497.     }
  498.     if( $prop->{pid_file_unlink} ){
  499.       push @chown_files, $prop->{pid_file};
  500.     }
  501.     if( $prop->{lock_file_unlink} ){
  502.       push @chown_files, $prop->{lock_file};
  503.     }
  504.     if( $prop->{chown_log_file} ){
  505.       delete $prop->{chown_log_file};
  506.       push @chown_files, $prop->{log_file};
  507.     }
  508.     my $uid = $prop->{user};
  509.     my $gid = (split(/\ /,$prop->{group}))[0];
  510.     foreach my $file (@chown_files){
  511.       chown($uid,$gid,$file)
  512.         or $self->fatal("Couldn't chown \"$file\" [$!]\n");
  513.     }
  514.   }
  515.  
  516.  
  517.   ### perform the chroot operation
  518.   if( defined $prop->{chroot} ){
  519.     if( ! -d $prop->{chroot} ){
  520.       $self->fatal("Specified chroot \"$prop->{chroot}\" doesn't exist.\n");
  521.     }else{
  522.       $self->log(2,"Chrooting to $prop->{chroot}\n");
  523.       chroot( $prop->{chroot} )
  524.         or $self->fatal("Couldn't chroot to \"$prop->{chroot}\": $!");
  525.     }
  526.   }
  527.  
  528.  
  529.   ### drop privileges
  530.   eval{
  531.     if( $prop->{group} ne $) ){
  532.       $self->log(2,"Setting gid to \"$prop->{group}\"");
  533.       set_gid( $prop->{group} );
  534.     }
  535.     if( $prop->{user} ne $> ){
  536.       $self->log(2,"Setting uid to \"$prop->{user}\"");
  537.       set_uid( $prop->{user} );
  538.     }
  539.   };
  540.   if( $@ ){
  541.     if( $> == 0 ){
  542.       $self->fatal( $@ );
  543.     } elsif( $< == 0){
  544.       $self->log(2,"NOTICE: Effective UID changed, but Real UID is 0: $@");
  545.     }else{
  546.       $self->log(2,$@);
  547.     }
  548.   }
  549.  
  550.   ### record number of request
  551.   $prop->{requests} = 0;
  552.  
  553.   ### set some sigs
  554.   $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = sub { $self->server_close; };
  555.  
  556.   ### most cases, a closed pipe will take care of itself
  557.   $SIG{PIPE} = 'IGNORE';
  558.  
  559.   ### catch children (mainly for Fork and PreFork but works for any chld)
  560.   $SIG{CHLD} = \&sig_chld;
  561.  
  562.   ### catch sighup
  563.   $SIG{HUP} = sub { $self->sig_hup; }
  564.  
  565. }
  566.  
  567. ### routine to avoid zombie children
  568. sub sig_chld {
  569.   1 while (waitpid(-1, POSIX::WNOHANG()) > 0);
  570.   $SIG{CHLD} = \&sig_chld;
  571. }
  572.  
  573.  
  574. ### user customizable hook
  575. sub pre_loop_hook {}
  576.  
  577.  
  578. ### receive requests
  579. sub loop {
  580.   my $self = shift;
  581.  
  582.   while( $self->accept ){
  583.  
  584.     $self->run_client_connection;
  585.  
  586.     last if $self->done;
  587.  
  588.   }
  589. }
  590.  
  591.  
  592. ### wait for the connection
  593. sub accept {
  594.   my $self = shift;
  595.   my $prop = $self->{server};
  596.   my $sock = undef;
  597.   my $retries = 30;
  598.  
  599.   ### try awhile to get a defined client handle
  600.   ### normally a good handle should occur every time
  601.   while( $retries-- ){
  602.  
  603.     ### with more than one port, use select to get the next one
  604.     if( defined $prop->{multi_port} ){
  605.  
  606.       return 0 if defined $prop->{_HUP};
  607.  
  608.       ### anything server type specific
  609.       $sock = $self->accept_multi_port;
  610.       next unless $sock; # keep trying for the rest of retries
  611.  
  612.       return 0 if defined $prop->{_HUP};
  613.  
  614.       if ($self->can_read_hook($sock)) {
  615.         $retries ++;
  616.         next;
  617.       }
  618.  
  619.     ### single port is bound - just accept
  620.     }else{
  621.  
  622.       $sock = $prop->{sock}->[0];
  623.  
  624.     }
  625.  
  626.     ### make sure we got a good sock
  627.     if( not defined $sock ){
  628.       $self->fatal("Received a bad sock!");
  629.     }
  630.  
  631.     ### receive a udp packet
  632.     if( SOCK_DGRAM == $sock->getsockopt(Socket::SOL_SOCKET(),Socket::SO_TYPE()) ){
  633.       $prop->{client}   = $sock;
  634.       $prop->{udp_true} = 1;
  635.       $prop->{udp_peer} = $sock->recv($prop->{udp_data},
  636.                                       $sock->NS_recv_len,
  637.                                       $sock->NS_recv_flags,
  638.                                       );
  639.  
  640.     ### blocking accept per proto
  641.     }else{
  642.       delete $prop->{udp_true};
  643.       $prop->{client} = $sock->accept();
  644.  
  645.     }
  646.  
  647.     ### last one if HUPed
  648.     return 0 if defined $prop->{_HUP};
  649.  
  650.     ### success
  651.     return 1 if defined $prop->{client};
  652.  
  653.     $self->log(2,"Accept failed with $retries tries left: $!");
  654.  
  655.     ### try again in a second
  656.     sleep(1);
  657.  
  658.   }
  659.   $self->log(1,"Ran out of accept retries!");
  660.  
  661.   return undef;
  662. }
  663.  
  664.  
  665. ### server specific hook for multi port applications
  666. ### this actually applies to all but INET
  667. sub accept_multi_port {
  668.   my $self = shift;
  669.   my $prop = $self->{server};
  670.  
  671.   if( not exists $prop->{select} ){
  672.     $self->fatal("No select property during multi_port execution.");
  673.   }
  674.  
  675.   ### this will block until a client arrives
  676.   my @waiting = $prop->{select}->can_read();
  677.  
  678.   ### if no sockets, return failure
  679.   return undef unless @waiting;
  680.  
  681.   ### choose a socket
  682.   return $waiting[ rand(@waiting) ];
  683.  
  684. }
  685.  
  686. ### this occurs after a socket becomes readible on an accept_multi_port call.
  687. ### It is passed $self and the $sock that is readible.  A return value
  688. ### of true indicates to not pass the handle on to the process_request method and
  689. ### to return to accepting
  690. sub can_read_hook {}
  691.  
  692.  
  693. ### this occurs after the request has been processed
  694. ### this is server type specific (actually applies to all by INET)
  695. sub post_accept {
  696.   my $self = shift;
  697.   my $prop = $self->{server};
  698.  
  699.   ### keep track of the requests
  700.   $prop->{requests} ++;
  701.  
  702.   return if $prop->{udp_true}; # no need to do STDIN/STDOUT in UDP
  703.  
  704.   ### duplicate some handles and flush them
  705.   ### maybe we should save these somewhere - maybe not
  706.   if( defined $prop->{client} ){
  707.     if( ! $prop->{no_client_stdout} ){
  708.       my $fileno= fileno $prop->{client};
  709.       close STDIN;
  710.       close STDOUT;
  711.       if( defined $fileno ){
  712.           open STDIN,  "<&$fileno" or die "Couldn't open STDIN to the client socket: $!";
  713.           open STDOUT, ">&$fileno" or die "Couldn't open STDOUT to the client socket: $!";
  714.       } else {
  715.           *STDIN= \*{ $prop->{client} };
  716.           *STDOUT= \*{ $prop->{client} } if ! $prop->{client}->isa('IO::Socket::SSL');
  717.       }
  718.       STDIN->autoflush(1);
  719.       STDOUT->autoflush(1);
  720.       select(STDOUT);
  721.     }
  722.   }else{
  723.     $self->log(1,"Client socket information could not be determined!");
  724.   }
  725.  
  726. }
  727.  
  728. ### read information about the client connection
  729. sub get_client_info {
  730.   my $self = shift;
  731.   my $prop = $self->{server};
  732.   my $sock = $prop->{client};
  733.  
  734.   ### handle unix style connections
  735.   if( UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX' ){
  736.     my $path = $sock->NS_unix_path;
  737.     $self->log(3,$self->log_time
  738.                ." CONNECT UNIX Socket: \"$path\"\n");
  739.  
  740.     return;
  741.   }
  742.  
  743.   ### read information about this connection
  744.   my $sockname = getsockname( $sock );
  745.   if( $sockname ){
  746.     ($prop->{sockport}, $prop->{sockaddr})
  747.       = Socket::unpack_sockaddr_in( $sockname );
  748.     $prop->{sockaddr} = inet_ntoa( $prop->{sockaddr} );
  749.  
  750.   }else{
  751.     ### does this only happen from command line?
  752.     $prop->{sockaddr} = '0.0.0.0';
  753.     $prop->{sockhost} = 'inet.test';
  754.     $prop->{sockport} = 0;
  755.   }
  756.  
  757.   ### try to get some info about the remote host
  758.   my $proto_type = 'TCP';
  759.   if( $prop->{udp_true} ){
  760.     $proto_type = 'UDP';
  761.     ($prop->{peerport} ,$prop->{peeraddr})
  762.       = Socket::sockaddr_in( $prop->{udp_peer} );
  763.   }elsif( $prop->{peername} = getpeername( $sock ) ){
  764.     ($prop->{peerport}, $prop->{peeraddr})
  765.       = Socket::unpack_sockaddr_in( $prop->{peername} );
  766.   }
  767.  
  768.   if( $prop->{peername} || $prop->{udp_true} ){
  769.     $prop->{peeraddr} = inet_ntoa( $prop->{peeraddr} );
  770.  
  771.     if( defined $prop->{reverse_lookups} ){
  772.       $prop->{peerhost} = gethostbyaddr( inet_aton($prop->{peeraddr}), AF_INET );
  773.     }
  774.     $prop->{peerhost} = '' unless defined $prop->{peerhost};
  775.  
  776.   }else{
  777.     ### does this only happen from command line?
  778.     $prop->{peeraddr} = '0.0.0.0';
  779.     $prop->{peerhost} = 'inet.test';
  780.     $prop->{peerport} = 0;
  781.   }
  782.  
  783.   $self->log(3,$self->log_time
  784.              ." CONNECT $proto_type Peer: \"$prop->{peeraddr}:$prop->{peerport}\""
  785.              ." Local: \"$prop->{sockaddr}:$prop->{sockport}\"\n");
  786.  
  787. }
  788.  
  789. ### user customizable hook
  790. sub post_accept_hook {}
  791.  
  792.  
  793. ### perform basic allow/deny service
  794. sub allow_deny {
  795.   my $self = shift;
  796.   my $prop = $self->{server};
  797.   my $sock = $prop->{client};
  798.  
  799.   ### unix sockets are immune to this check
  800.   if( UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX' ){
  801.     return 1;
  802.   }
  803.  
  804.   ### if no allow or deny parameters are set, allow all
  805.   return 1 if
  806.        $#{ $prop->{allow} } == -1
  807.     && $#{ $prop->{deny} }  == -1
  808.     && $#{ $prop->{cidr_allow} } == -1
  809.     && $#{ $prop->{cidr_deny} }  == -1;
  810.  
  811.   ### if the addr or host matches a deny, reject it immediately
  812.   foreach ( @{ $prop->{deny} } ){
  813.     return 0 if $prop->{peerhost} =~ /^$_$/ && defined($prop->{reverse_lookups});
  814.     return 0 if $prop->{peeraddr} =~ /^$_$/;
  815.   }
  816.   if ($#{ $prop->{cidr_deny} } != -1) {
  817.     require Net::CIDR;
  818.     return 0 if Net::CIDR::cidrlookup($prop->{peeraddr}, @{ $prop->{cidr_deny} });
  819.   }
  820.  
  821.  
  822.   ### if the addr or host isn't blocked yet, allow it if it is allowed
  823.   foreach ( @{ $prop->{allow} } ){
  824.     return 1 if $prop->{peerhost} =~ /^$_$/ && defined($prop->{reverse_lookups});
  825.     return 1 if $prop->{peeraddr} =~ /^$_$/;
  826.   }
  827.   if ($#{ $prop->{cidr_allow} } != -1) {
  828.     require Net::CIDR;
  829.     return 1 if Net::CIDR::cidrlookup($prop->{peeraddr}, @{ $prop->{cidr_allow} });
  830.   }
  831.  
  832.   return 0;
  833. }
  834.  
  835.  
  836. ### user customizable hook
  837. ### if this hook returns 1 the request is processed
  838. ### if this hook returns 0 the request is denied
  839. sub allow_deny_hook { 1 }
  840.  
  841.  
  842. ### user customizable hook
  843. sub request_denied_hook {}
  844.  
  845.  
  846. ### this is the main method to override
  847. ### this is where most of the work will occur
  848. ### A sample server is shown below.
  849. sub process_request {
  850.   my $self = shift;
  851.   my $prop = $self->{server};
  852.  
  853.   ### handle udp packets (udp echo server)
  854.   if( $prop->{udp_true} ){
  855.     if( $prop->{udp_data} =~ /dump/ ){
  856.       require Data::Dumper;
  857.       $prop->{client}->send( Data::Dumper::Dumper( $self ) , 0);
  858.     }else{
  859.       $prop->{client}->send("You said \"$prop->{udp_data}\"", 0 );
  860.     }
  861.     return;
  862.   }
  863.  
  864.  
  865.   ### handle tcp connections (tcp echo server)
  866.   print "Welcome to \"".ref($self)."\" ($$)\r\n";
  867.  
  868.   ### eval block needed to prevent DoS by using timeout
  869.   my $timeout = 30; # give the user 30 seconds to type a line
  870.   my $previous_alarm = alarm($timeout);
  871.   eval {
  872.  
  873.     local $SIG{ALRM} = sub { die "Timed Out!\n" };
  874.  
  875.     while( <STDIN> ){
  876.  
  877.       s/\r?\n$//;
  878.  
  879.       print ref($self),":$$: You said \"$_\"\r\n";
  880.       $self->log(5,$_); # very verbose log
  881.  
  882.       if( /get (\w+)/ ){
  883.         print "$1: $self->{server}->{$1}\r\n";
  884.       }
  885.  
  886.       if( /dump/ ){
  887.         require Data::Dumper;
  888.         print Data::Dumper::Dumper( $self );
  889.       }
  890.  
  891.       if( /quit/ ){ last }
  892.  
  893.       if( /exit/ ){ $self->server_close }
  894.  
  895.       alarm($timeout);
  896.     }
  897.  
  898.   };
  899.   alarm($previous_alarm);
  900.  
  901.  
  902.   if ($@ eq "Timed Out!\n") {
  903.     print STDOUT "Timed Out.\r\n";
  904.     return;
  905.   }
  906.  
  907. }
  908.  
  909.  
  910. ### user customizable hook
  911. sub post_process_request_hook {}
  912.  
  913. sub post_client_connection_hook {}
  914.  
  915. ### this is server type specific functions after the process
  916. sub post_process_request {
  917.   my $self = shift;
  918.   my $prop = $self->{server};
  919.  
  920.   ### don't do anything for udp
  921.   return if $prop->{udp_true};
  922.  
  923.   ### close the client socket handle
  924.   if( ! $prop->{no_client_stdout} ){
  925.     # close handles - but leave fd's around to prevent spurious messages (Rob Mueller)
  926.     #close STDIN;
  927.     #close STDOUT;
  928.     open(STDIN,  '</dev/null') || die "Can't read /dev/null  [$!]";
  929.     open(STDOUT, '>/dev/null') || die "Can't write /dev/null [$!]";
  930.   }
  931.   close($prop->{client});
  932.  
  933. }
  934.  
  935.  
  936. ### determine if I am done with a request
  937. ### in the base type, we are never done until a SIG occurs
  938. sub done {
  939.   my $self = shift;
  940.   $self->{server}->{done} = shift if @_;
  941.   return $self->{server}->{done};
  942. }
  943.  
  944.  
  945. ### fork off a child process to handle dequeuing
  946. sub run_dequeue {
  947.   my $self = shift;
  948.   my $pid  = fork;
  949.  
  950.   ### trouble
  951.   if( not defined $pid ){
  952.     $self->fatal("Bad fork [$!]");
  953.  
  954.   ### parent
  955.   }elsif( $pid ){
  956.     $self->{server}->{children}->{$pid}->{status} = 'dequeue';
  957.  
  958.   ### child
  959.   }else{
  960.     $self->dequeue();
  961.     exit;
  962.   }
  963. }
  964.  
  965. ### sub process which could be implemented to
  966. ### perform tasks such as clearing a mail queue.
  967. ### currently only supported in PreFork
  968. sub dequeue {}
  969.  
  970.  
  971. ### user customizable hook
  972. sub pre_server_close_hook {}
  973.  
  974. ### this happens when the server reaches the end
  975. sub server_close{
  976.   my $self = shift;
  977.   my $prop = $self->{server};
  978.  
  979.   $SIG{INT} = 'DEFAULT';
  980.  
  981.   ### if this is a child process, signal the parent and close
  982.   ### normally the child shouldn't, but if they do...
  983.   ### otherwise the parent continues with the shutdown
  984.   ### this is safe for non standard forked child processes
  985.   ### as they will not have server_close as a handler
  986.   if (defined $prop->{ppid}
  987.       && $prop->{ppid} != $$
  988.       && ! defined $prop->{no_close_by_child}) {
  989.     $self->close_parent;
  990.     exit;
  991.   }
  992.  
  993.   ### allow for customizable closing
  994.   $self->pre_server_close_hook;
  995.  
  996.   $self->log(2,$self->log_time . " Server closing!");
  997.  
  998.   if (defined $prop->{_HUP} && $prop->{leave_children_open_on_hup}) {
  999.       $self->hup_children;
  1000.  
  1001.   } else {
  1002.       ### shut down children if any
  1003.       if( defined $prop->{children} ){
  1004.           $self->close_children();
  1005.       }
  1006.  
  1007.       ### allow for additional cleanup phase
  1008.       $self->post_child_cleanup_hook();
  1009.   }
  1010.  
  1011.   ### remove files
  1012.   if( defined $prop->{lock_file}
  1013.       && -e $prop->{lock_file}
  1014.       && defined $prop->{lock_file_unlink} ){
  1015.     unlink($prop->{lock_file}) || $self->log(1, "Couldn't unlink \"$prop->{lock_file}\" [$!]");
  1016.   }
  1017.   if( defined $prop->{pid_file}
  1018.       && -e $prop->{pid_file}
  1019.       && defined $prop->{pid_file_unlink} ){
  1020.     unlink($prop->{pid_file}) || $self->log(1, "Couldn't unlink \"$prop->{pid_file}\" [$!]");
  1021.   }
  1022.  
  1023.   ### HUP process
  1024.   if( defined $prop->{_HUP} ){
  1025.  
  1026.     $self->restart_close_hook();
  1027.  
  1028.     $self->hup_server; # execs at the end
  1029.   }
  1030.  
  1031.   ### we don't need the ports - close everything down
  1032.   $self->shutdown_sockets;
  1033.  
  1034.   ### all done - exit
  1035.   $self->server_exit;
  1036. }
  1037.  
  1038. ### called at end once the server has exited
  1039. sub server_exit { exit }
  1040.  
  1041. ### allow for fully shutting down the bound sockets
  1042. sub shutdown_sockets {
  1043.   my $self = shift;
  1044.   my $prop = $self->{server};
  1045.  
  1046.   ### unlink remaining socket files (if any)
  1047.   foreach my $sock ( @{ $prop->{sock} } ){
  1048.     $sock->shutdown(2); # close sockets - nobody should be reading/writing still
  1049.  
  1050.     unlink $sock->NS_unix_path
  1051.       if $sock->NS_proto eq 'UNIX';
  1052.   }
  1053.  
  1054.   ### delete the sock objects
  1055.   $prop->{sock} = [];
  1056.  
  1057.   return 1;
  1058. }
  1059.  
  1060. ### Allow children to send INT signal to parent (or use another method)
  1061. ### This method is only used by forking servers
  1062. sub close_parent {
  1063.   my $self = shift;
  1064.   my $prop = $self->{server};
  1065.   die "Missing parent pid (ppid)" if ! $prop->{ppid};
  1066.   kill 2, $prop->{ppid};
  1067. }
  1068.  
  1069. ### SIG INT the children
  1070. ### This method is only used by forking servers (ie Fork, PreFork)
  1071. sub close_children {
  1072.   my $self = shift;
  1073.   my $prop = $self->{server};
  1074.  
  1075.   return unless defined $prop->{children} && scalar keys %{ $prop->{children} };
  1076.  
  1077.   foreach my $pid (keys %{ $prop->{children} }) {
  1078.     ### if it is killable, kill it
  1079.     if( ! defined($pid) || kill(15,$pid) || ! kill(0,$pid) ){
  1080.       $self->delete_child( $pid );
  1081.     }
  1082.  
  1083.   }
  1084.  
  1085.   ### need to wait off the children
  1086.   ### eventually this should probably use &check_sigs
  1087.   1 while waitpid(-1, POSIX::WNOHANG()) > 0;
  1088.  
  1089. }
  1090.  
  1091.  
  1092. sub is_prefork { 0 }
  1093.  
  1094. sub hup_children {
  1095.   my $self = shift;
  1096.   my $prop = $self->{server};
  1097.  
  1098.   return unless defined $prop->{children} && scalar keys %{ $prop->{children} };
  1099.   return if ! $self->is_prefork;
  1100.   $self->log(2, "Sending children hup signal during HUP on prefork server\n");
  1101.  
  1102.   foreach my $pid (keys %{ $prop->{children} }) {
  1103.       kill(1,$pid); # try to hup it
  1104.   }
  1105. }
  1106.  
  1107. sub post_child_cleanup_hook {}
  1108.  
  1109. ### handle sig hup
  1110. ### this will prepare the server for a restart via exec
  1111. sub sig_hup {
  1112.   my $self = shift;
  1113.   my $prop = $self->{server};
  1114.  
  1115.   ### prepare for exec
  1116.   my $i  = 0;
  1117.   my @fd = ();
  1118.   $prop->{_HUP} = [];
  1119.   foreach my $sock ( @{ $prop->{sock} } ){
  1120.  
  1121.     ### duplicate the sock
  1122.     my $fd = POSIX::dup($sock->fileno)
  1123.       or $self->fatal("Can't dup socket [$!]");
  1124.  
  1125.     ### hold on to the socket copy until exec
  1126.     $prop->{_HUP}->[$i] = IO::Socket::INET->new;
  1127.     $prop->{_HUP}->[$i]->fdopen($fd, 'w')
  1128.       or $self->fatal("Can't open to file descriptor [$!]");
  1129.  
  1130.     ### turn off the FD_CLOEXEC bit to allow reuse on exec
  1131.     $prop->{_HUP}->[$i]->fcntl( Fcntl::F_SETFD(), my $flags = "" );
  1132.  
  1133.     ### save host,port,proto, and file descriptor
  1134.     push @fd, $fd .'|'. $sock->hup_string;
  1135.  
  1136.     ### remove anything that may be blocking
  1137.     $sock->close();
  1138.  
  1139.     $i++;
  1140.   }
  1141.  
  1142.   ### remove any blocking obstacle
  1143.   if( defined $prop->{select} ){
  1144.     delete $prop->{select};
  1145.   }
  1146.  
  1147.   $ENV{BOUND_SOCKETS} = join("\n", @fd);
  1148.  
  1149.   if ($prop->{leave_children_open_on_hup} && scalar keys %{ $prop->{children} }) {
  1150.       $ENV{HUP_CHILDREN} = join("\n", map {"$_\t$prop->{children}->{$_}->{status}"} sort keys %{ $prop->{children} });
  1151.   }
  1152. }
  1153.  
  1154. ### restart the server using prebound sockets
  1155. sub hup_server {
  1156.   my $self = shift;
  1157.  
  1158.   $self->log(0,$self->log_time()." HUP'ing server");
  1159.  
  1160.   delete $ENV{$_} for $self->hup_delete_env_keys;
  1161.  
  1162.   exec @{ $self->commandline };
  1163. }
  1164.  
  1165. sub hup_delete_env_keys { return qw(PATH) }
  1166.  
  1167. ### this hook occurs if a server has been HUP'ed
  1168. ### it occurs just before opening to the fileno's
  1169. sub restart_open_hook {}
  1170.  
  1171. ### this hook occurs if a server has been HUP'ed
  1172. ### it occurs just before exec'ing the server
  1173. sub restart_close_hook {}
  1174.  
  1175. ###----------------------------------------------------------###
  1176.  
  1177. ### what to do when all else fails
  1178. sub fatal {
  1179.   my $self = shift;
  1180.   my $error = shift;
  1181.   my ($package,$file,$line) = caller;
  1182.   $self->fatal_hook($error, $package, $file, $line);
  1183.  
  1184.   $self->log(0, $self->log_time ." ". $error
  1185.              ."\n  at line $line in file $file");
  1186.  
  1187.   $self->server_close;
  1188. }
  1189.  
  1190.  
  1191. ### user customizable hook
  1192. sub fatal_hook {}
  1193.  
  1194. ###----------------------------------------------------------###
  1195.  
  1196. ### handle opening syslog
  1197. sub open_syslog {
  1198.   my $self = shift;
  1199.   my $prop = $self->{server};
  1200.  
  1201.   require Sys::Syslog;
  1202.  
  1203.   if (ref($prop->{syslog_logsock}) eq 'ARRAY') {
  1204.     # do nothing - assume they have what they want
  1205.   } else {
  1206.     if (! defined $prop->{syslog_logsock}) {
  1207.       $prop->{syslog_logsock} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : '';
  1208.     }
  1209.     if ($prop->{syslog_logsock} =~ /^(|native|tcp|udp|unix|inet|stream|console)$/) {
  1210.       $prop->{syslog_logsock} = $1;
  1211.     } else {
  1212.       $prop->{syslog_logsock} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : '';
  1213.     }
  1214.   }
  1215.  
  1216.   my $ident = defined($prop->{syslog_ident})
  1217.     ? $prop->{syslog_ident} : 'net_server';
  1218.   $prop->{syslog_ident} = ($ident =~ /^([\ -~]+)$/)
  1219.     ? $1 : 'net_server';
  1220.  
  1221.  
  1222.   my $opt = defined($prop->{syslog_logopt})
  1223.     ? $prop->{syslog_logopt} : $Sys::Syslog::VERSION ge '0.15' ? 'pid,nofatal' : 'pid';
  1224.   $prop->{syslog_logopt} = ($opt =~ /^( (?: (?:cons|ndelay|nowait|pid|nofatal) (?:$|[,|]) )* )/x)
  1225.     ? $1 : 'pid';
  1226.  
  1227.   my $fac = defined($prop->{syslog_facility})
  1228.     ? $prop->{syslog_facility} : 'daemon';
  1229.   $prop->{syslog_facility} = ($fac =~ /^((\w+)($|\|))*/)
  1230.     ? $1 : 'daemon';
  1231.  
  1232.   if ($prop->{syslog_logsock}) {
  1233.     Sys::Syslog::setlogsock($prop->{syslog_logsock}) || die "Syslog err [$!]";
  1234.   }
  1235.   if( ! Sys::Syslog::openlog($prop->{syslog_ident},
  1236.                              $prop->{syslog_logopt},
  1237.                              $prop->{syslog_facility}) ){
  1238.     die "Couldn't open syslog [$!]" if $prop->{syslog_logopt} ne 'ndelay';
  1239.   }
  1240. }
  1241.  
  1242. ### how internal levels map to syslog levels
  1243. $Net::Server::syslog_map = {0 => 'err',
  1244.                             1 => 'warning',
  1245.                             2 => 'notice',
  1246.                             3 => 'info',
  1247.                             4 => 'debug'};
  1248.  
  1249. ### record output
  1250. sub log {
  1251.   my ($self, $level, $msg, @therest) = @_;
  1252.   my $prop = $self->{server};
  1253.  
  1254.   return if ! $prop->{log_level};
  1255.  
  1256.   ### log only to syslog if setup to do syslog
  1257.   if (defined($prop->{log_file}) && $prop->{log_file} eq 'Sys::Syslog') {
  1258.     if ($level =~ /^\d+$/) {
  1259.         return if $level > $prop->{log_level};
  1260.         $level = $Net::Server::syslog_map->{$level} || $level;
  1261.     }
  1262.  
  1263.     my $ok = eval {
  1264.       if (@therest) { # if more parameters are passed, we must assume that the first is a format string
  1265.         Sys::Syslog::syslog($level, $msg, @therest);
  1266.       } else {
  1267.         Sys::Syslog::syslog($level, '%s', $msg);
  1268.       }
  1269.       1;
  1270.     };
  1271.  
  1272.     if (! $ok) {
  1273.         my $err = $@;
  1274.         $self->handle_syslog_error($err, [$level, $msg, @therest]);
  1275.     }
  1276.  
  1277.     return;
  1278.   } else {
  1279.     return if $level !~ /^\d+$/ || $level > $prop->{log_level};
  1280.   }
  1281.  
  1282.   $self->write_to_log_hook($level, $msg);
  1283. }
  1284.  
  1285. ### allow catching syslog errors
  1286. sub handle_syslog_error {
  1287.   my ($self, $error) = @_;
  1288.   die $error;
  1289. }
  1290.  
  1291. ### standard log routine, this could very easily be
  1292. ### overridden with a syslog call
  1293. sub write_to_log_hook {
  1294.   my ($self, $level, $msg) = @_;
  1295.   my $prop = $self->{server};
  1296.   chomp $msg;
  1297.   $msg =~ s/([^\n\ -\~])/sprintf("%%%02X",ord($1))/eg;
  1298.  
  1299.   if( $prop->{log_file} ){
  1300.     print _SERVER_LOG $msg, "\n";
  1301.   }elsif( $prop->{setsid} ){
  1302.     # do nothing
  1303.   }else{
  1304.     my $old = select(STDERR);
  1305.     print $msg. "\n";
  1306.     select($old);
  1307.   }
  1308.  
  1309. }
  1310.  
  1311.  
  1312. ### default time format
  1313. sub log_time {
  1314.   my ($sec,$min,$hour,$day,$mon,$year) = localtime;
  1315.   return sprintf("%04d/%02d/%02d-%02d:%02d:%02d",
  1316.                  $year+1900, $mon+1, $day, $hour, $min, $sec);
  1317. }
  1318.  
  1319. ###----------------------------------------------------------###
  1320.  
  1321. ### set up default structure
  1322. sub options {
  1323.   my $self = shift;
  1324.   my $prop = $self->{server};
  1325.   my $ref  = shift;
  1326.  
  1327.   foreach ( qw(port host proto allow deny cidr_allow cidr_deny) ){
  1328.     if (! defined $prop->{$_}) {
  1329.       $prop->{$_} = [];
  1330.     } elsif (! ref $prop->{$_}) {
  1331.       $prop->{$_} = [$prop->{$_}]; # nicely turn us into an arrayref if we aren't one already
  1332.     }
  1333.     $ref->{$_} = $prop->{$_};
  1334.   }
  1335.  
  1336.   foreach ( qw(conf_file
  1337.                user group chroot log_level
  1338.                log_file pid_file background setsid
  1339.                listen reverse_lookups
  1340.                syslog_logsock syslog_ident
  1341.                syslog_logopt syslog_facility
  1342.                no_close_by_child
  1343.                no_client_stdout
  1344.                leave_children_open_on_hup
  1345.                ) ){
  1346.     $ref->{$_} = \$prop->{$_};
  1347.   }
  1348.  
  1349. }
  1350.  
  1351.  
  1352. ### routine for parsing commandline, module, and conf file
  1353. ### possibly should use Getopt::Long but this
  1354. ### method has the benefit of leaving unused arguments in @ARGV
  1355. sub process_args {
  1356.   my $self = shift;
  1357.   my $ref  = shift;
  1358.   my $template = shift; # allow for custom passed in template
  1359.  
  1360.   ### if no template is passed, obtain our own
  1361.   if (! $template || ! ref($template)) {
  1362.     $template = {};
  1363.     $self->options( $template );
  1364.   }
  1365.  
  1366.   ### we want subsequent calls to not overwrite or add to
  1367.   ### previously set values so that command line arguments win
  1368.   my %previously_set;
  1369.  
  1370.   foreach (my $i=0 ; $i < @$ref ; $i++) {
  1371.  
  1372.     if ($ref->[$i] =~ /^(?:--)?(\w+)([=\ ](\S+))?$/
  1373.         && exists $template->{$1}) {
  1374.       my ($key,$val) = ($1,$3);
  1375.       splice( @$ref, $i, 1 );
  1376.       if (not defined($val)) {
  1377.         if ($i > $#$ref
  1378.             || ($ref->[$i] && $ref->[$i] =~ /^--\w+/)) {
  1379.           $val = 1; # allow for options such as --setsid
  1380.         } else {
  1381.           $val = splice( @$ref, $i, 1 );
  1382.           if (ref $val) {
  1383.             die "Found an invalid configuration value for \"$key\" ($val)" if ref($val) ne 'ARRAY';
  1384.             $val = $val->[0] if @$val == 1;
  1385.           }
  1386.         }
  1387.       }
  1388.       $i--;
  1389.       $val =~ s/%([A-F0-9])/chr(hex $1)/eig if ! ref $val;;
  1390.  
  1391.       if (ref $template->{$key} eq 'ARRAY') {
  1392.         if (! defined $previously_set{$key}) {
  1393.           $previously_set{$key} = scalar @{ $template->{$key} };
  1394.         }
  1395.         next if $previously_set{$key};
  1396.         push @{ $template->{$key} }, ref($val) ? @$val : $val;
  1397.       } else {
  1398.         if (! defined $previously_set{$key}) {
  1399.           $previously_set{$key} = defined(${ $template->{$key} }) ? 1 : 0;
  1400.         }
  1401.         next if $previously_set{$key};
  1402.         die "Found multiple values on the configuration item \"$key\" which expects only one value" if ref $val;
  1403.         ${ $template->{$key} } = $val;
  1404.       }
  1405.     }
  1406.  
  1407.   }
  1408.  
  1409. }
  1410.  
  1411.  
  1412. ### routine for loading conf file parameters
  1413. ### cache the args temporarily to handle multiple calls
  1414. sub process_conf {
  1415.   my $self = shift;
  1416.   my $file = shift;
  1417.   my $template = shift;
  1418.   $template = undef if ! $template || ! ref($template);
  1419.   my @args = ();
  1420.  
  1421.   if( ! $self->{server}->{conf_file_args} ){
  1422.     $file = ($file =~ m|^([\w\.\-\/\\\:]+)$|)
  1423.       ? $1 : $self->fatal("Unsecure filename \"$file\"");
  1424.  
  1425.     if( not open(_CONF,"<$file") ){
  1426.       if (! $ENV{BOUND_SOCKETS}) {
  1427.         warn "Couldn't open conf \"$file\" [$!]\n";
  1428.       }
  1429.       $self->fatal("Couldn't open conf \"$file\" [$!]");
  1430.     }
  1431.  
  1432.     while(<_CONF>){
  1433.       push( @args, "$1=$2") if m/^\s*((?:--)?\w+)(?:\s*[=:]\s*|\s+)(\S+)/;
  1434.     }
  1435.  
  1436.     close(_CONF);
  1437.  
  1438.     $self->{server}->{conf_file_args} = \@args;
  1439.   }
  1440.  
  1441.   $self->process_args( $self->{server}->{conf_file_args}, $template );
  1442. }
  1443.  
  1444. ### remove a child from the children hash. Not to be called by user.
  1445. ### if UNIX sockets are in use the socket is removed from the select object.
  1446. sub delete_child {
  1447.   my $self = shift;
  1448.   my $pid  = shift;
  1449.   my $prop = $self->{server};
  1450.  
  1451.   ### don't remove children that don't belong to me (Christian Mock, Luca Filipozzi)
  1452.   return unless exists $prop->{children}->{$pid};
  1453.  
  1454.   ### prefork server check to clear child communication
  1455.   if( $prop->{child_communication} ){
  1456.     if ($prop->{children}->{$pid}->{sock}) {
  1457.       $prop->{child_select}->remove( $prop->{children}->{$pid}->{sock} );
  1458.       $prop->{children}->{$pid}->{sock}->close;
  1459.     }
  1460.   }
  1461.  
  1462.   delete $prop->{children}->{$pid};
  1463. }
  1464.  
  1465. ###----------------------------------------------------------###
  1466. sub get_property {
  1467.   my $self = shift;
  1468.   my $key  = shift;
  1469.   $self->{server} = {} unless defined $self->{server};
  1470.   return $self->{server}->{$key} if exists $self->{server}->{$key};
  1471.   return undef;
  1472. }
  1473.  
  1474. sub set_property {
  1475.   my $self = shift;
  1476.   my $key  = shift;
  1477.   $self->{server} = {} unless defined $self->{server};
  1478.   $self->{server}->{$key}  = shift;
  1479. }
  1480.  
  1481. ###----------------------------------------------------------------###
  1482.  
  1483. 1;
  1484.  
  1485. ### The documentation is in Net/Server.pod
  1486.